#install.packages('gtable')DM 2 - Eva Racine - Isabelle Lignières
Eva Racine et Isabelle Lignières
Devoir II - Etude de table de mortalité
Importation des données :
Mise en place des paramètres et des packages :
Nous avons eu un message d’erreur de ” Error in draw_axis(break_positions = guide$key[[aesthetic]], break_labels = guide$key$.label, : lazy-load database ‘/Library/Frameworks/R.framework/Versions/4.2/Resources/library/gtable/R/gtable.rdb’ is corrupt “. C’est un problème avec le package. En lancant ce code, le problème s’est résolu :
params = list(
truc= "Science des Données",
year= 2023 ,
country_code= 'fr_t',
country= 'France',
datafile= 'full_life_table.Rds',
year_p= 1948,
year_e= 2017
)require(patchwork)Loading required package: patchwork
require(glue)Loading required package: glue
require(here)Loading required package: here
here() starts at /Users/evaracine/FAC/L3/S6/SCIENCES DES DONNÉES
require(tidyverse)Loading required package: tidyverse
── Attaching core tidyverse packages ──────────────────────── tidyverse 2.0.0 ──
✔ dplyr 1.1.4 ✔ readr 2.1.4
✔ forcats 1.0.0 ✔ stringr 1.5.1
✔ ggplot2 3.4.4 ✔ tibble 3.2.1
✔ lubridate 1.9.3 ✔ tidyr 1.3.0
✔ purrr 1.0.2
── Conflicts ────────────────────────────────────────── tidyverse_conflicts() ──
✖ dplyr::filter() masks stats::filter()
✖ dplyr::lag() masks stats::lag()
ℹ Use the conflicted package (<http://conflicted.r-lib.org/>) to force all conflicts to become errors
require(plotly)Loading required package: plotly
Attaching package: 'plotly'
The following object is masked from 'package:ggplot2':
last_plot
The following object is masked from 'package:stats':
filter
The following object is masked from 'package:graphics':
layout
require(DT)Loading required package: DT
require(ggforce)Loading required package: ggforce
install.packages("demography", repos = "https://cran.r-project.org")
The downloaded binary packages are in
/var/folders/_7/vlg1zj650wzfbmjfd6lg1f480000gn/T//RtmpmJzJR7/downloaded_packages
old_theme <-theme_set(theme_minimal(base_size=9, base_family = "Helvetica"))Importation de la table de données :
datafile <- 'full_life_table.Rds'
fpath <- stringr::str_c("./DATA/", datafile)
# here::here('DATA', datafile)
# check getwd() if problem
if (! file.exists(fpath)) {
download.file("https://stephane-v-boucheron.fr/data/full_life_table.Rds",
fpath,
mode="wb")
}
life_table <- readr::read_rds(fpath)life_table <- life_table %>%
mutate(Country = as_factor(Country)) %>%
mutate(Country = fct_relevel(Country, "Spain", "Italy", "France",
"England & Wales", "Netherlands", "Sweden", "USA")) %>%
mutate(Gender = as_factor(Gender))
life_table <- life_table %>%
mutate(Area = fct_collapse(Country,
SE = c("Spain", "Italy", "France"),
NE = c("England & Wales", "Netherlands", "Sweden"),
USA="USA"))
life_table# A tibble: 379,170 × 13
Year Age mx qx ax lx dx Lx Tx ex Country
<int> <int> <dbl> <dbl> <dbl> <int> <int> <int> <int> <dbl> <fct>
1 1816 0 0.205 0.180 0.31 100000 17972 87524 4009912 40.1 France
2 1816 1 0.0467 0.0456 0.5 82028 3742 80156 3922388 47.8 France
3 1816 2 0.0341 0.0336 0.5 78285 2626 76972 3842232 49.1 France
4 1816 3 0.0230 0.0228 0.5 75659 1723 74798 3765260 49.8 France
5 1816 4 0.0160 0.0159 0.5 73936 1176 73348 3690462 49.9 France
6 1816 5 0.0137 0.0136 0.5 72760 992 72264 3617114 49.7 France
7 1816 6 0.0119 0.0118 0.5 71768 846 71344 3544850 49.4 France
8 1816 7 0.0102 0.0101 0.5 70921 717 70563 3473506 49.0 France
9 1816 8 0.00864 0.0086 0.5 70204 604 69902 3402943 48.5 France
10 1816 9 0.00734 0.00732 0.5 69601 509 69346 3333041 47.9 France
# ℹ 379,160 more rows
# ℹ 2 more variables: Gender <fct>, Area <fct>
Question 1 :
On filtre d’abord la base de données pour garder les années de 1900 à 1913. De plus, la question nous demande une illustration pour chaque sexe. On va donc garder uniquement “Female” et “Male” et supprimer “Both” qui regroupe les deux car cela ne nous servira pas ici :
life_table_1900a1913 <- life_table |> filter(Year>=1900 & Year<=1913) |> subset(Gender=="Male" | Gender=="Female") |> group_by(Country, Gender)
life_table_1900a1913# A tibble: 16,720 × 13
# Groups: Country, Gender [12]
Year Age mx qx ax lx dx Lx Tx ex Country
<int> <int> <dbl> <dbl> <dbl> <int> <int> <int> <int> <dbl> <fct>
1 1900 0 0.166 0.149 0.31 100000 14934 89757 4695469 47.0 France
2 1900 1 0.0333 0.0328 0.5 85066 2789 83671 4605712 54.1 France
3 1900 2 0.018 0.0178 0.5 82277 1467 81543 4522041 55.0 France
4 1900 3 0.0117 0.0116 0.5 80809 938 80340 4440498 55.0 France
5 1900 4 0.00925 0.0092 0.5 79871 735 79504 4360158 54.6 France
6 1900 5 0.00651 0.00649 0.5 79136 513 78879 4280654 54.1 France
7 1900 6 0.00559 0.00557 0.5 78622 438 78403 4201775 53.4 France
8 1900 7 0.00475 0.00474 0.5 78184 371 77999 4123372 52.7 France
9 1900 8 0.0043 0.00429 0.5 77813 334 77646 4045373 52.0 France
10 1900 9 0.00386 0.00385 0.5 77479 298 77330 3967727 51.2 France
# ℹ 16,710 more rows
# ℹ 2 more variables: Gender <fct>, Area <fct>
Ensuite, on illustre pour chaque pays et chaque sexe, l’évolution des quotients de mortalité.
On étudie donc le quotient de mortalité correspondant à la colonne “qx” qui représente le risque de mortalité à l’âge x.
On remarque qu’on peut étudier qx comme une fonction de l’année t, mais aussi pour une année donnée, étudier qx comme une fonction de l’âge x (cf. sujet Devoir 2). On va donc représenter ces deux manières.
Evolution des quotients de mortalité en fonction de l’âge pour une année t fixée entre 1900 et 1913 :
proto_plt2 <-
ggplot() +
aes(x=Age, y=qx, colour=Country, frame=Year, linetype=Country) +
theme(plot.title = element_text(size = 12, face = "bold", hjust = 0.5)) +
geom_point(size=.1) +
geom_line(size=.1) +
scale_y_log10() +
labs(linetype=c("Country")) +
scale_x_continuous(breaks = c(seq(0, 100, 10), 109)) +
xlab("Age") +
ylab("Central death rates") +
facet_grid(cols=vars(Gender))Warning: Using `size` aesthetic for lines was deprecated in ggplot2 3.4.0.
ℹ Please use `linewidth` instead.
with(params,
(proto_plt2 %+%
(life_table_1900a1913) +
ggtitle("Evolution des quotients de mortalité entre 1900 et 1913 en fonction de l'âge\n pour une année donnée"))) %>%
plotly::ggplotly()Warning in p$x$data[firstFrame] <- p$x$frames[[1]]$data: number of items to
replace is not a multiple of replacement length
Evolution des quotients de mortalité en fonction des années entre 1900 et 1913 pour un âge x fixé :
proto_plt3 <-
ggplot() +
aes(x=Year, y=qx, colour=Country, frame=Age, linetype=Country) +
theme(plot.title = element_text(size = 12, face = "bold", hjust = 0.5)) +
geom_point(size=.5) +
geom_line(size=.1) +
scale_y_log10() +
labs(linetype=c("Country")) +
scale_x_continuous(breaks = c(seq(1900, 1913, 3))) +
xlab("Year") +
ylab("Central death rates") +
facet_grid(cols=vars(Gender))
with(params,
(proto_plt3 %+%
(life_table_1900a1913) +
ggtitle("Evolution des quotients de mortalité entre 1900 et 1913 pour un âge donné"))) %>%
plotly::ggplotly()Commentaire :
Nous n’avons pas de données avant 1908 pour l’Espagne. Les courbes de l’Espagne se démarquent dans les deux graphes par de fortes fluctuations. Ceci peut être expliqué par des facteurs historiques (“el retraso” espagnol) ou par le manque de données puisqu’elles ne datent que de 1908.
Premier graphique : Nous avons une forme de courbe en V que nous retrouvons au cours des 13 années avec un minimum à 10 ans. Pour la partie décroissante entre 0 et 10 ans, le risque de mourir chute ce qui est notamment dû aux nombreux riques liés à l’accouchement et la grossesse (morts-nés comptabilisé). Pour la croissance entre 10 et 109 ans, le risque de mourir à l’âge x augmente. Plus les personnes vieillissent, plus elles risquent de mourir.
Deuxième graphique : Les courbes décroissent légèrement entre 1900 et 1913. Le risque de mourir à un âge x diminue au fil des ans. La décroissance est plus nette pour les âges compris entre 0 et 13 ans.
Question 2 :
Régression linéaire du logarithme du quotient de mortalité entre 1900 et 1913 :
On cherche à effectuer pour chaque pays, chaque sexe et chaque année entre 1900 et 1913 une régression linéaire du logarithme du quotient de mortalité en fonction de l’âge, pour des âges compris entre 30 et 70 ans.
Premièrement, on va filtrer la base de données pour selectionner ce qui nous intéresse. On peut reprendre la base de données filtrée précédente qui prend les données entre 1900 et 1913. A cela, on selectionne uniquement les âges entre 30 et 70 ans, et on ajoute une colonne qui représente le logarithme du quotient de mortalité qx.
life_table_1900_1913_3070 <- life_table_1900a1913 |> filter(Age<=70 & Age>=30) |> mutate(logqx = log(qx)) |> group_by(Country, Gender)
life_table_1900_1913_3070# A tibble: 6,232 × 14
# Groups: Country, Gender [12]
Year Age mx qx ax lx dx Lx Tx ex Country
<int> <int> <dbl> <dbl> <dbl> <int> <int> <int> <int> <dbl> <fct>
1 1900 30 0.00814 0.00811 0.5 68372 555 68095 2423117 35.4 France
2 1900 31 0.00817 0.00814 0.5 67818 552 67542 2355022 34.7 France
3 1900 32 0.00856 0.00852 0.5 67266 573 66979 2287481 34.0 France
4 1900 33 0.00865 0.00861 0.5 66692 574 66405 2220502 33.3 France
5 1900 34 0.00828 0.00825 0.5 66118 545 65845 2154097 32.6 France
6 1900 35 0.0088 0.00877 0.5 65572 575 65285 2088251 31.8 France
7 1900 36 0.00898 0.00894 0.5 64998 581 64707 2022966 31.1 France
8 1900 37 0.0089 0.00886 0.5 64416 571 64131 1958259 30.4 France
9 1900 38 0.00913 0.00909 0.5 63845 580 63555 1894129 29.7 France
10 1900 39 0.00929 0.00924 0.5 63265 585 62973 1830573 28.9 France
# ℹ 6,222 more rows
# ℹ 3 more variables: Gender <fct>, Area <fct>, logqx <dbl>
On peut par la suite illustrer la régression linéaire. On crée le même modèle de graphique que précédemment. La régression linéaire simple pour chaque pays, chaque sexe et chaque année se fera grâce à geom_smooth(method=“lm”, se=FALSE). En effet, lm est la fonction de R pour la régression.
graph_reglin_0013 <-
ggplot() +
aes(x=Age, y=logqx, colour=Country, frame=Year)+
theme(plot.title = element_text(size = 12, face = "bold", hjust = 0.5)) +
geom_smooth(method="lm", se=FALSE)+
geom_point(size=.3) +
geom_line(size=.1) +
labs(linetype=c("Country")) +
scale_x_continuous(breaks = c(seq(30, 70, 10), 70)) +
xlab("Age") +
ylab("logarithme du quotient de mortalité") +
facet_grid(cols=vars(Gender))
with(params,
(graph_reglin_0013 %+%
(life_table_1900_1913_3070) +
ggtitle("Régression linéaire du logarithme du quotient de mortalité en fonction de l'âge"))) %>%
plotly::ggplotly()`geom_smooth()` using formula = 'y ~ x'
Warning in p$x$data[firstFrame] <- p$x$frames[[1]]$data: number of items to
replace is not a multiple of replacement length
Les données se superposent mais on peut les isoler.
Régression linéaire du logarithme du quotient de mortalité entre 1921 et 1925 :
On filtre la base de données.
life_table_1921_1925_3070 <- life_table |> filter(Year>=1921 & Year<=1925, Age<=70 & Age>=30, Gender!="Both") |> mutate(logqx = log(qx)) |> group_by(Country, Gender)
life_table_1921_1925_3070# A tibble: 2,460 × 14
# Groups: Country, Gender [12]
Year Age mx qx ax lx dx Lx Tx ex Country
<int> <int> <dbl> <dbl> <dbl> <int> <int> <int> <int> <dbl> <fct>
1 1921 30 0.00599 0.00597 0.5 77095 460 76864 2982817 38.7 France
2 1921 31 0.00588 0.00586 0.5 76634 449 76410 2905953 37.9 France
3 1921 32 0.00606 0.00604 0.5 76185 460 75955 2829543 37.1 France
4 1921 33 0.006 0.00598 0.5 75725 453 75499 2753588 36.4 France
5 1921 34 0.00624 0.00622 0.5 75272 468 75038 2678089 35.6 France
6 1921 35 0.00641 0.00638 0.5 74804 478 74565 2603051 34.8 France
7 1921 36 0.00642 0.0064 0.5 74327 476 74089 2528486 34.0 France
8 1921 37 0.0068 0.00677 0.5 73851 500 73601 2454397 33.2 France
9 1921 38 0.00689 0.00686 0.5 73351 503 73099 2380796 32.5 France
10 1921 39 0.00676 0.00674 0.5 72848 491 72602 2307697 31.7 France
# ℹ 2,450 more rows
# ℹ 3 more variables: Gender <fct>, Area <fct>, logqx <dbl>
On peut par la suite illustrer la régression linéaire. On crée le même modèle de graphique que précédemment. La régression linéaire simple pour chaque pays, chaque sexe et chaque année se fera grâce à geom_smooth(method=“lm”, se=FALSE). En effet, lm est la fonction de R pour la régression. C’est en fait la même chose que pour 1900 à 1913.
graph_reglin_2125 <-
ggplot() +
aes(x=Age, y=logqx, colour=Country, frame=Year)+
theme(plot.title = element_text(size = 12, face = "bold", hjust = 0.5)) +
geom_smooth(method="lm", se=FALSE)+
geom_point(size=.3) +
geom_line(size=.1) +
labs(linetype=c("Country")) +
scale_x_continuous(breaks = c(seq(30, 70, 10), 70)) +
xlab("Age") +
ylab("logarithme du quotient de mortalité") +
facet_grid(cols=vars(Gender))
with(params,
(graph_reglin_2125 %+%
(life_table_1921_1925_3070) +
ggtitle("Régression linéaire du logarithme du quotient de mortalité en fonction de l'âge"))) %>%
plotly::ggplotly()`geom_smooth()` using formula = 'y ~ x'
Commentaire :
La régression linéaire nous permet de remarquer que le quotient de mortalité est croissant entre 30 et 70 ans. Le risque de mourir à l’âge x croît lorsque x (l’âge) croît. Le logarithme du quotient de mortalité varie entre -6 et -3 car le quotient de mortalité varie entre 0,01 et 0,04 des nombres compris entre 0 et 1 donc le logarithme est négatif.
Question 3 :
Il faut illustrer la différence entre les quotients de mortalité tirés des tables du moment de l’année 1890 et les quotient de mortalité effectivement subis entre 1890 et 1980. Pour cela on va créer deux tables (la table du moment de 1890 et la table de génération) et les joindre.
Ensuite, on pourra comparer les deux quotients de mortalité : celui du moment pendant l’année de naissance et celui réel.
Table du moment de 1890 :
La table du moment est la table qui contient pour chaque année les risques de mortalité à différents âge pour la même année. Ainsi, la table du moment de 1890 ci-dessous nous donne tous les quotients de mortalité pour chaque âge en 1890 (pour chaque pays et chaque sexe). On s’arrête à 90 ans car la question se pose de 1890 à 1980, soit 90 ans.
moment_1890 <- life_table |> filter(Year==1890, Age<=90) |> group_by(Country, Gender)
moment_1890# A tibble: 1,365 × 13
# Groups: Country, Gender [15]
Year Age mx qx ax lx dx Lx Tx ex Country
<int> <int> <dbl> <dbl> <dbl> <int> <int> <int> <int> <dbl> <fct>
1 1890 0 0.180 0.160 0.31 100000 15993 88898 4343367 43.4 France
2 1890 1 0.0551 0.0536 0.5 84007 4503 81755 4254469 50.6 France
3 1890 2 0.027 0.0266 0.5 79503 2118 78444 4172714 52.5 France
4 1890 3 0.0177 0.0176 0.5 77385 1360 76705 4094270 52.9 France
5 1890 4 0.0129 0.0128 0.5 76025 975 75538 4017565 52.8 France
6 1890 5 0.00947 0.00942 0.5 75050 707 74697 3942027 52.5 France
7 1890 6 0.00694 0.00692 0.5 74343 514 74086 3867330 52.0 France
8 1890 7 0.00505 0.00504 0.5 73829 372 73643 3793244 51.4 France
9 1890 8 0.0038 0.0038 0.5 73457 279 73318 3719601 50.6 France
10 1890 9 0.00319 0.00319 0.5 73178 233 73062 3646283 49.8 France
# ℹ 1,355 more rows
# ℹ 2 more variables: Gender <fct>, Area <fct>
Table de génération :
La table de génération est comme une suite. On suit la cohorte des individus nés en 1890 jusqu’en 1980. C’est à dire qu’on regarde les quotients de mortalité à la naissance en 1890, puis les quotients de mortalité à un an en 1891, etc… jusqu’au quotient à l’âge de 90 ans en 1980.
cohorte_1890 <-data.frame()
for(i in 0:90) {
cohorte_1890 <- cohorte_1890 |> rbind(life_table|> filter(Age==i & Year==(1890+i)))
}
cohorte_1890# A tibble: 1,728 × 13
Year Age mx qx ax lx dx Lx Tx ex Country Gender
<int> <int> <dbl> <dbl> <dbl> <int> <int> <int> <int> <dbl> <fct> <fct>
1 1890 0 0.180 0.160 0.31 100000 15993 88898 4343367 43.4 France Both
2 1890 0 0.162 0.146 0.31 100000 14618 89974 4483572 44.8 France Female
3 1890 0 0.197 0.173 0.3 100000 17298 87877 4210587 42.1 France Male
4 1890 0 0.162 0.145 0.31 100000 14543 89904 4471978 44.7 Englan… Both
5 1890 0 0.145 0.132 0.31 100000 13185 90957 4652857 46.5 Englan… Female
6 1890 0 0.178 0.158 0.3 100000 15845 88895 4295384 43.0 Englan… Male
7 1890 0 0.208 0.182 0.31 100000 18183 87377 4441719 44.4 Nether… Both
8 1890 0 0.187 0.166 0.31 100000 16562 88640 4576372 45.8 Nether… Female
9 1890 0 0.229 0.197 0.3 100000 19710 86186 4312684 43.1 Nether… Male
10 1890 0 0.218 0.189 0.31 100000 18903 86882 3857641 38.6 Italy Both
# ℹ 1,718 more rows
# ℹ 1 more variable: Area <fct>
On joint ensuite les deux tables grâce à la fonction merge vue dans le DM précédent.
all_cohorte_1890 <- merge(moment_1890, cohorte_1890, by=c("Age",'Gender', "Country")) |> rename("qx.1890"=qx.x, "qx.reel"=qx.y)
tail(all_cohorte_1890) Age Gender Country Year.x mx.x qx.1890 ax.x lx.x dx.x Lx.x Tx.x
1360 90 Female Sweden 1890 0.32119 0.27675 0.5 2611 723 2249 6974
1361 90 Male England & Wales 1890 0.35411 0.30085 0.5 599 180 509 1496
1362 90 Male France 1890 0.38924 0.32582 0.5 557 181 466 1296
1363 90 Male Italy 1890 0.36321 0.30738 0.5 712 219 602 1714
1364 90 Male Netherlands 1890 0.37671 0.31700 0.5 712 226 600 1695
1365 90 Male Sweden 1890 0.35181 0.29919 0.5 1547 463 1315 3856
ex.x Area.x Year.y mx.y qx.reel ax.y lx.y dx.y Lx.y Tx.y ex.y Area.y
1360 2.67 NE 1980 0.19743 0.17969 0.5 17541 3152 15965 66839 3.81 NE
1361 2.50 NE 1980 0.26902 0.23713 0.5 4673 1108 4119 14806 3.17 NE
1362 2.33 SE 1980 0.25406 0.22542 0.5 6067 1368 5383 19512 3.22 SE
1363 2.41 SE 1980 0.27562 0.24224 0.5 5325 1290 4680 16325 3.07 SE
1364 2.38 NE 1980 0.23223 0.20807 0.5 7330 1525 6568 25795 3.52 NE
1365 2.49 NE 1980 0.27766 0.24381 0.5 7063 1722 6202 22137 3.13 NE
Pour mettre en évidence la différence entre les deux quotients de mortalité, on peut les tracer pour chaque pays et les séparer en fonction du genre. On va d’abord transformer les colonnes qx.1890 et qx.reel en ligne.
all_cohorte_1890_long <- all_cohorte_1890 |>
pivot_longer(cols=c("qx.1890", "qx.reel"), names_to="Qx", values_to = "valeur.qx")
all_cohorte_1890_long# A tibble: 2,730 × 23
Age Gender Country Year.x mx.x ax.x lx.x dx.x Lx.x Tx.x ex.x Area.x
<int> <fct> <fct> <int> <dbl> <dbl> <int> <int> <int> <int> <dbl> <fct>
1 0 Both Englan… 1890 0.162 0.31 1e5 14543 89904 4.47e6 44.7 NE
2 0 Both Englan… 1890 0.162 0.31 1e5 14543 89904 4.47e6 44.7 NE
3 0 Both France 1890 0.180 0.31 1e5 15993 88898 4.34e6 43.4 SE
4 0 Both France 1890 0.180 0.31 1e5 15993 88898 4.34e6 43.4 SE
5 0 Both Italy 1890 0.218 0.31 1e5 18903 86882 3.86e6 38.6 SE
6 0 Both Italy 1890 0.218 0.31 1e5 18903 86882 3.86e6 38.6 SE
7 0 Both Nether… 1890 0.208 0.31 1e5 18183 87377 4.44e6 44.4 NE
8 0 Both Nether… 1890 0.208 0.31 1e5 18183 87377 4.44e6 44.4 NE
9 0 Both Sweden 1890 0.112 0.31 1e5 10435 92755 5.04e6 50.4 NE
10 0 Both Sweden 1890 0.112 0.31 1e5 10435 92755 5.04e6 50.4 NE
# ℹ 2,720 more rows
# ℹ 11 more variables: Year.y <int>, mx.y <dbl>, ax.y <dbl>, lx.y <int>,
# dx.y <int>, Lx.y <int>, Tx.y <int>, ex.y <dbl>, Area.y <fct>, Qx <chr>,
# valeur.qx <dbl>
Pour la France :
FR_1890 <- all_cohorte_1890_long |> filter(Country=='France')
FR_1890# A tibble: 546 × 23
Age Gender Country Year.x mx.x ax.x lx.x dx.x Lx.x Tx.x ex.x
<int> <fct> <fct> <int> <dbl> <dbl> <int> <int> <int> <int> <dbl>
1 0 Both France 1890 0.180 0.31 100000 15993 88898 4343367 43.4
2 0 Both France 1890 0.180 0.31 100000 15993 88898 4343367 43.4
3 0 Female France 1890 0.162 0.31 100000 14618 89974 4483572 44.8
4 0 Female France 1890 0.162 0.31 100000 14618 89974 4483572 44.8
5 0 Male France 1890 0.197 0.3 100000 17298 87877 4210587 42.1
6 0 Male France 1890 0.197 0.3 100000 17298 87877 4210587 42.1
7 1 Both France 1890 0.0551 0.5 84007 4503 81755 4254469 50.6
8 1 Both France 1890 0.0551 0.5 84007 4503 81755 4254469 50.6
9 1 Female France 1890 0.0534 0.5 85382 4438 83163 4393599 51.5
10 1 Female France 1890 0.0534 0.5 85382 4438 83163 4393599 51.5
# ℹ 536 more rows
# ℹ 12 more variables: Area.x <fct>, Year.y <int>, mx.y <dbl>, ax.y <dbl>,
# lx.y <int>, dx.y <int>, Lx.y <int>, Tx.y <int>, ex.y <dbl>, Area.y <fct>,
# Qx <chr>, valeur.qx <dbl>
g_france <- ggplot(FR_1890) +
aes(x = Age, y =valeur.qx, group = Qx, color = Qx) +
geom_line(aes(color=Qx))+
facet_grid(Gender ~ Country, scales = "free") +
labs(title = "Comparaison des quotients de mortalité des tables du moment \nde 1890 et des quotients de mortalité effectivement subis pour la France",
x = "Age",
y = "Valeur du quotient de mortalité",
color = "Quotients de mortalité") +
theme(plot.title = element_text(size = 12, face = "bold", hjust = 0.5),
legend.position = "bottom",
axis.title.x = element_text(size = 8, face = "bold", hjust = 0.5),
axis.title.y = element_text(size = 8, face = "bold", hjust = 0.5))
g_france
Pour l’Italie :
IT_1890 <- all_cohorte_1890_long |> filter(Country=='Italy')
IT_1890# A tibble: 546 × 23
Age Gender Country Year.x mx.x ax.x lx.x dx.x Lx.x Tx.x ex.x
<int> <fct> <fct> <int> <dbl> <dbl> <int> <int> <int> <int> <dbl>
1 0 Both Italy 1890 0.218 0.31 100000 18903 86882 3857641 38.6
2 0 Both Italy 1890 0.218 0.31 100000 18903 86882 3857641 38.6
3 0 Female Italy 1890 0.205 0.31 100000 17969 87675 3861739 38.6
4 0 Female Italy 1890 0.205 0.31 100000 17969 87675 3861739 38.6
5 0 Male Italy 1890 0.230 0.3 100000 19781 86136 3855662 38.6
6 0 Male Italy 1890 0.230 0.3 100000 19781 86136 3855662 38.6
7 1 Both Italy 1890 0.0756 0.5 81097 5909 78142 3770759 46.5
8 1 Both Italy 1890 0.0756 0.5 81097 5909 78142 3770759 46.5
9 1 Female Italy 1890 0.0770 0.5 82031 6080 78991 3774064 46.0
10 1 Female Italy 1890 0.0770 0.5 82031 6080 78991 3774064 46.0
# ℹ 536 more rows
# ℹ 12 more variables: Area.x <fct>, Year.y <int>, mx.y <dbl>, ax.y <dbl>,
# lx.y <int>, dx.y <int>, Lx.y <int>, Tx.y <int>, ex.y <dbl>, Area.y <fct>,
# Qx <chr>, valeur.qx <dbl>
g_italie <- ggplot(IT_1890) +
aes(x = Age, y =valeur.qx, group = Qx, color = Qx) +
geom_line(aes(color=Qx))+
facet_grid(Gender ~ Country, scales = "free") +
labs(title = "Comparaison des quotients de mortalité des tables du moment \nde 1890 et des quotients de mortalité effectivement subis pour l'Italie",
x = "Age",
y = "Valeur du quotient de mortalité",
color = "Quotients de mortalité") +
theme(plot.title = element_text(size = 12, face = "bold", hjust = 0.5),
legend.position = "bottom",
axis.title.x = element_text(size = 8, face = "bold", hjust = 0.5),
axis.title.y = element_text(size = 8, face = "bold", hjust = 0.5))
g_italie
Pour l’Angleterre et Pays de Galles :
EW_1890 <- all_cohorte_1890_long |> filter(Country=='England & Wales')
EW_1890# A tibble: 546 × 23
Age Gender Country Year.x mx.x ax.x lx.x dx.x Lx.x Tx.x ex.x
<int> <fct> <fct> <int> <dbl> <dbl> <int> <int> <int> <int> <dbl>
1 0 Both England & W… 1890 0.162 0.31 100000 14543 89904 4.47e6 44.7
2 0 Both England & W… 1890 0.162 0.31 100000 14543 89904 4.47e6 44.7
3 0 Female England & W… 1890 0.145 0.31 100000 13185 90957 4.65e6 46.5
4 0 Female England & W… 1890 0.145 0.31 100000 13185 90957 4.65e6 46.5
5 0 Male England & W… 1890 0.178 0.3 100000 15845 88895 4.30e6 43.0
6 0 Male England & W… 1890 0.178 0.3 100000 15845 88895 4.30e6 43.0
7 1 Both England & W… 1890 0.0582 0.5 85457 4835 83040 4.38e6 51.3
8 1 Both England & W… 1890 0.0582 0.5 85457 4835 83040 4.38e6 51.3
9 1 Female England & W… 1890 0.0564 0.5 86815 4761 84435 4.56e6 52.6
10 1 Female England & W… 1890 0.0564 0.5 86815 4761 84435 4.56e6 52.6
# ℹ 536 more rows
# ℹ 12 more variables: Area.x <fct>, Year.y <int>, mx.y <dbl>, ax.y <dbl>,
# lx.y <int>, dx.y <int>, Lx.y <int>, Tx.y <int>, ex.y <dbl>, Area.y <fct>,
# Qx <chr>, valeur.qx <dbl>
g_enwa <- ggplot(EW_1890) +
aes(x = Age, y =valeur.qx, group = Qx, color = Qx) +
geom_line(aes(color=Qx))+
facet_grid(Gender ~ Country, scales = "free") +
labs(title = "Comparaison des quotients de mortalité des tables du moment \nde 1890 et des quotients de mortalité effectivement subis pour l'Angleterre et Pays de Gales",
x = "Age",
y = "Valeur du quotient de mortalité",
color = "Quotients de mortalité") +
theme(plot.title = element_text(size = 12, face = "bold", hjust = 0.5),
legend.position = "bottom",
axis.title.x = element_text(size = 8, face = "bold", hjust = 0.5),
axis.title.y = element_text(size = 8, face = "bold", hjust = 0.5))
g_enwa
Pour les Pays-Bas :
NETH_1890 <- all_cohorte_1890_long |> filter(Country=='Netherlands')
NETH_1890# A tibble: 546 × 23
Age Gender Country Year.x mx.x ax.x lx.x dx.x Lx.x Tx.x ex.x
<int> <fct> <fct> <int> <dbl> <dbl> <int> <int> <int> <int> <dbl>
1 0 Both Netherlands 1890 0.208 0.31 100000 18183 87377 4441719 44.4
2 0 Both Netherlands 1890 0.208 0.31 100000 18183 87377 4441719 44.4
3 0 Female Netherlands 1890 0.187 0.31 100000 16562 88640 4576372 45.8
4 0 Female Netherlands 1890 0.187 0.31 100000 16562 88640 4576372 45.8
5 0 Male Netherlands 1890 0.229 0.3 100000 19710 86186 4312684 43.1
6 0 Male Netherlands 1890 0.229 0.3 100000 19710 86186 4312684 43.1
7 1 Both Netherlands 1890 0.0548 0.5 81817 4365 79634 4354342 53.2
8 1 Both Netherlands 1890 0.0548 0.5 81817 4365 79634 4354342 53.2
9 1 Female Netherlands 1890 0.0540 0.5 83438 4388 81244 4487732 53.8
10 1 Female Netherlands 1890 0.0540 0.5 83438 4388 81244 4487732 53.8
# ℹ 536 more rows
# ℹ 12 more variables: Area.x <fct>, Year.y <int>, mx.y <dbl>, ax.y <dbl>,
# lx.y <int>, dx.y <int>, Lx.y <int>, Tx.y <int>, ex.y <dbl>, Area.y <fct>,
# Qx <chr>, valeur.qx <dbl>
g_neth <- ggplot(NETH_1890) +
aes(x = Age, y =valeur.qx, group = Qx, color = Qx) +
geom_line(aes(color=Qx))+
facet_grid(Gender ~ Country, scales = "free") +
labs(title = "Comparaison des quotients de mortalité des tables du moment \nde 1890 et des quotients de mortalité effectivement subis pour les Pays-Bas",
x = "Age",
y = "Valeur du quotient de mortalité",
color = "Quotients de mortalité") +
theme(plot.title = element_text(size = 12, face = "bold", hjust = 0.5),
legend.position = "bottom",
axis.title.x = element_text(size = 8, face = "bold", hjust = 0.5),
axis.title.y = element_text(size = 8, face = "bold", hjust = 0.5))
g_neth
Pour la Suède :
SWE_1890 <- all_cohorte_1890_long |> filter(Country=='Sweden')
SWE_1890# A tibble: 546 × 23
Age Gender Country Year.x mx.x ax.x lx.x dx.x Lx.x Tx.x ex.x
<int> <fct> <fct> <int> <dbl> <dbl> <int> <int> <int> <int> <dbl>
1 0 Both Sweden 1890 0.112 0.31 100000 10435 92755 5044007 50.4
2 0 Both Sweden 1890 0.112 0.31 100000 10435 92755 5044007 50.4
3 0 Female Sweden 1890 0.101 0.31 100000 9408 93547 5177133 51.8
4 0 Female Sweden 1890 0.101 0.31 100000 9408 93547 5177133 51.8
5 0 Male Sweden 1890 0.124 0.3 100000 11412 92002 4908335 49.1
6 0 Male Sweden 1890 0.124 0.3 100000 11412 92002 4908335 49.1
7 1 Both Sweden 1890 0.0337 0.5 89565 2967 88082 4951252 55.3
8 1 Both Sweden 1890 0.0337 0.5 89565 2967 88082 4951252 55.3
9 1 Female Sweden 1890 0.0334 0.5 90592 2974 89105 5083586 56.1
10 1 Female Sweden 1890 0.0334 0.5 90592 2974 89105 5083586 56.1
# ℹ 536 more rows
# ℹ 12 more variables: Area.x <fct>, Year.y <int>, mx.y <dbl>, ax.y <dbl>,
# lx.y <int>, dx.y <int>, Lx.y <int>, Tx.y <int>, ex.y <dbl>, Area.y <fct>,
# Qx <chr>, valeur.qx <dbl>
g_suede <- ggplot(SWE_1890) +
aes(x = Age, y =valeur.qx, group = Qx, color = Qx) +
geom_line(aes(color=Qx))+
facet_grid(Gender ~ Country, scales = "free") +
labs(title = "Comparaison des quotients de mortalité des tables du moment \nde 1890 et des quotients de mortalité effectivement subis pour la Suède",
x = "Age",
y = "Valeur du quotient de mortalité",
color = "Quotients de mortalité") +
theme(plot.title = element_text(size = 12, face = "bold", hjust = 0.5),
legend.position = "bottom",
axis.title.x = element_text(size = 8, face = "bold", hjust = 0.5),
axis.title.y = element_text(size = 8, face = "bold", hjust = 0.5))
g_suede
Commentaire :
Les courbes du quotient de mortalité de la table de moment et de la table de génération sont identiques entre 0 et 50 ans excepté vers 25 pour pratiquement tous les pays.
On observe deux différences : un pic de la courbe du quotient de mortalité réel vers 25 ans et la courbe du quotient de mortalité réel est en dessous de celle des quotients de mortalité tirés de la table de moment après 50 ans.
Pic vers 25 ans : On observe un pic (plus ou moins prononcé selon le sexe et le pays) de la courbe du quotient réel vers l’âge de 25 ans, ce qui correspond aux années 1914 (1890+24) et 1918 (1890+28) et donc à la première guerre mondiale. Les personnes, particulièrement les hommes, nées en 1890 à l’âge de 25 ans sont confrontées à de nombreux risques dus à la première guerre mondiale. La France, l’Italie, l’Angleterre et les Pays-Bas ont un pic plus prononcé puisqu’ils sont des pays qui ont été au coeur de la guerre (le front est en France). Les hommes sont plus mort entre 24 et 28 ans que ce qui était prévu en 1890 vu que la table de moment de 1890 ne tenait pas compte la première guerre mondiale.
Après 50 ans : Pour tous les pays la courbe du quotient de mortalité réel après 50 ans passe en dessous de celle du quotient de mortalité de la table de moment. Le risque de mourir après 50 ans a diminué par rapport à 1890.